home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / clos-kludge / clos-patch.l next >
Lisp/Scheme  |  1989-07-12  |  4KB  |  153 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Base:10; Lowercase:YES; Patch-file:T; Syntax:Common-Lisp -*-
  2.  
  3. ;;; This file integrates CLX with CLOS
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21.  
  22. ;;; THIS FILE MUST BE LOADED IMMEDIATELY AFTER THE CLX/dependent.l FILE
  23. ;;; WHILE CLX IS BEING COMPILED.  IT RE-DEFINES DRAWABLE, WINDOW AND PIXMAP
  24. ;;; TO BE CLOS CLASSES.
  25.  
  26.  
  27. #+comment ;; This should work, but doesn't on Franz Lisp...
  28. (eval-when (compile load eval)
  29.   (cond ((find-package 'clos)
  30.      (in-package 'xlib :use '(lisp clos)))
  31.     ((find-package 'ticlos)
  32.      (in-package 'xlib :use '(lisp ticlos)))
  33.     ((find-package 'cluei) ;; must be using clos-kludge
  34.      (in-package 'cluei :use '(lisp xlib)))
  35.     (t (error "Can't find a CLOS")))
  36. )
  37. ;; Set the package with this cruft instead
  38. #+pcl
  39. (in-package 'xlib :use '(lisp pcl))
  40. #+(and clos (not explorer) (not pcl))
  41. (in-package 'xlib :use '(lisp clos))
  42. #+(and clos explorer (not pcl))
  43. (in-package 'xlib :use '(lisp ticlos))
  44. #-(or pcl clos)
  45. (in-package 'cluei :use '(lisp xlib))
  46.  
  47.  
  48. ;; Nuke defstruct info from drawable window and pixmap
  49. (eval-when (compile load eval)
  50.   (dolist (symbol '( drawable drawable-id drawable-display drawable-plist make-drawable drawable-p
  51.              window window-id window-display window-plist make-window window-p
  52.              pixmap pixmap-id pixmap-display pixmap-plist make-pixmap pixmap-p))
  53.     (setf (symbol-plist symbol) nil)
  54.     (fmakunbound symbol))
  55.   )
  56.  
  57. ;;
  58. ;; Drawables
  59. ;;
  60.  
  61. ;; Allow change in metaclass (structure-class to standard-class)
  62. (setf (find-class 'drawable nil) nil)
  63.  
  64. (defclass drawable ()
  65.   ((id      :type     resource-id
  66.         :initform 0
  67.         :accessor drawable-id
  68.         :initarg  :id)
  69.    
  70.    (display :type     (or null display)
  71.         :initform nil
  72.         :accessor drawable-display
  73.         :initarg  :display)
  74.    
  75.    (plist   :type     list
  76.         :initform nil
  77.         :accessor drawable-plist
  78.         :initarg  :plist))        ; Extension hook
  79.  
  80.   (:documentation "The class of CLX drawable objects."))
  81.  
  82.  
  83. (defun make-drawable (&rest initargs)
  84.   (apply #'make-instance 'drawable initargs))
  85.  
  86. (defun drawable-p (object)
  87.   (typep object 'drawable))
  88.  
  89. ;;
  90. ;; Windows
  91. ;;
  92.  
  93. ;; Allow change in metaclass (structure-class to standard-class)
  94. (setf (find-class 'window nil) nil)
  95.  
  96. (defclass window (drawable)
  97.   ((id      :type     resource-id
  98.         :initform 0
  99.         :accessor window-id
  100.         :initarg  :id)
  101.    
  102.    (display :type     (or null display)
  103.         :initform nil
  104.         :accessor window-display
  105.         :initarg  :display)
  106.    
  107.    (plist   :type     list
  108.         :initform nil
  109.         :accessor window-plist
  110.         :initarg  :plist))        ; Extension hook
  111.  
  112.   (:documentation "The class of CLX window objects."))
  113.  
  114.  
  115. (defun make-window (&rest initargs)
  116.   (apply #'make-instance 'window initargs))
  117.  
  118. (defun window-p (object)
  119.   (typep object 'window))
  120.  
  121.  
  122. ;;
  123. ;; Pixmaps
  124. ;;
  125.  
  126. ;; Allow change in metaclass (structure-class to standard-class)
  127. (setf (find-class 'pixmap nil) nil)
  128.  
  129. (defclass pixmap (drawable)
  130.   ((id      :type     resource-id
  131.         :initform 0
  132.         :accessor pixmap-id
  133.         :initarg  :id)
  134.    
  135.    (display :type     (or null display)
  136.         :initform nil
  137.         :accessor pixmap-display
  138.         :initarg  :display)
  139.    
  140.    (plist   :type     list
  141.         :initform nil
  142.         :accessor pixmap-plist
  143.         :initarg  :plist))        ; Extension hook
  144.  
  145.   (:documentation "The class of CLX pixmap objects."))
  146.  
  147.  
  148. (defun make-pixmap (&rest initargs)
  149.   (apply #'make-instance 'pixmap initargs))
  150.  
  151. (defun pixmap-p (object)
  152.   (typep object 'pixmap))
  153.